home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 98 / Skunkware 98.iso / src / interp / tclStruct1.2.tar.gz / tclStruct1.2.tar / tclStruct1.2 / stInfo.c < prev    next >
C/C++ Source or Header  |  1995-09-12  |  14KB  |  466 lines
  1. /*
  2.  *    tclStruct package
  3.  *  Support 'C' structures in Tcl
  4.  *
  5.  *  Written by Matthew Costello
  6.  *  (c) 1995 AT&T Global Information Solutions, Dayton Ohio USA
  7.  *
  8.  *  See the file "license.terms" for information on usage and
  9.  *  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  10.  */
  11. #include "stInternal.h"
  12. STRUCT_SCCSID("@(#)tclStruct:stInfo.c    1.3    95/09/12")
  13.  
  14.  
  15. /*
  16.  * Struct_Typeof
  17.  *
  18.  *    Take an object or type name and return the type
  19.  *    of the entity.
  20.  *
  21.  * Returns:
  22.  *    attached type on success
  23.  *    NULL and interp->result on error
  24.  */
  25. Struct_TypeDef *
  26. Struct_Typeof(cdata, interp, name)
  27.   ClientData cdata;
  28.   Tcl_Interp *interp;
  29.   CONST char *name;
  30. {
  31.     Struct_TypeDef *type;
  32.     Struct_Object objbuf;
  33.  
  34.     if ((type = Struct_LookupType(cdata,interp,name)) != NULL) {
  35.     return type;
  36.     }
  37.  
  38.     if (Struct_GetObject(interp,name,&objbuf) == TCL_OK) {
  39.     return objbuf.type;
  40.     }
  41.  
  42.     return NULL;
  43. }
  44.  
  45.  
  46. /*
  47.  *----------------------------------------------------------------------
  48.  *
  49.  * Struct_InfoCmd --
  50.  *
  51.  *    This procedure is invoked to process the "struct_info" Tcl command.
  52.  *    See the user documentation for details on what it does.
  53.  *
  54.  * Results:
  55.  *    A standard Tcl result.
  56.  *
  57.  * Side effects:
  58.  *    See the user documentation.
  59.  *
  60.  *----------------------------------------------------------------------
  61.  */
  62. int
  63. Struct_InfoCmd(cdata, interp, argc, argv)
  64.   ClientData cdata;
  65.   Tcl_Interp *interp;            /* Current interpreter. */
  66.   int argc;                /* Number of arguments. */
  67.   char **argv;                /* Argument strings. */
  68. {
  69.     unsigned int length;
  70.     Struct_TypeDef *type;
  71.  
  72.     if (cdata == NULL) {
  73.     Tcl_AppendResult(interp, "NULL clientData in Struct_InfoCmd",NULL);
  74.     return TCL_ERROR;
  75.     }
  76.     Struct_PkgInfo(cdata,si_cmdCount) += 1;
  77.     if (argc < 2) {
  78.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  79.         " option ?arg arg ...?\"", (char *) NULL);
  80.     return TCL_ERROR;
  81.     }
  82. #ifdef DEBUG
  83.     if (struct_debug & (DBG_COMMAND)) Struct_PrintCommand(argc,argv);
  84. #endif
  85.     length = strlen(argv[1]);
  86.     switch (argv[1][0]) {
  87.       case 'b':
  88.     if (strncmp(argv[1], "builtins", length) == 0) {
  89.         Tcl_HashEntry *entryPtr;
  90.         Tcl_HashSearch search;
  91.         char *name;
  92.         if (argc > 3) {
  93.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  94.             argv[0], " types ?pattern?\"", (char *) NULL);
  95.         return TCL_ERROR;
  96.         }
  97.         for ( entryPtr = Tcl_FirstHashEntry(Struct_TypeHash(cdata), &search);
  98.               entryPtr != NULL;
  99.           entryPtr = Tcl_NextHashEntry(&search) ) {
  100.         if (!(((Struct_TypeDef *)Tcl_GetHashValue(entryPtr))->flags & STRUCT_FLAG_BUILTIN))
  101.             continue;
  102.         name = Tcl_GetHashKey(Struct_TypeHash(cdata), entryPtr);
  103.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  104.             continue;
  105.         }
  106.         Tcl_AppendElement(interp, name);
  107.         }
  108.         return TCL_OK;
  109.     }
  110.     break;
  111.       case 'c':
  112.     if (strncmp(argv[1], "count", length) == 0) {
  113.         if (argc != 3) {
  114.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  115.             " count ?item?\"", (char *) NULL);
  116.         return TCL_ERROR;
  117.         }
  118.         length = strlen(argv[2]);
  119.         if (strncmp(argv[2],"command",length) == 0) {
  120.             length = Struct_PkgInfo(cdata,si_cmdCount);
  121.         } else if (strncmp(argv[2],"read",length) == 0) {
  122.             length = Struct_PkgInfo(cdata,si_rdCount);
  123.         } else if (strncmp(argv[2],"write",length) == 0) {
  124.             length = Struct_PkgInfo(cdata,si_wrCount);
  125.         } else if (strncmp(argv[2],"newtype",length) == 0) {
  126.             length = Struct_PkgInfo(cdata,si_nNewTypes);
  127. #ifdef ACCESS_TO_INTERPRETER
  128.         } else if (strncmp(argv[2],"extype",length) == 0) {
  129.             length = Struct_PkgInfo(cdata,si_nExTypes);
  130. #endif
  131.         } else if (strncmp(argv[2],"reset",length) == 0) {
  132.             Struct_PkgInfo(cdata,si_cmdCount) = 0;
  133.             Struct_PkgInfo(cdata,si_rdCount) = 0;
  134.             Struct_PkgInfo(cdata,si_wrCount) = 0;
  135.             Struct_PkgInfo(cdata,si_nNewTypes) = 0;
  136.             Struct_PkgInfo(cdata,si_nExTypes) = 0;
  137.             return TCL_OK;
  138.         } else {
  139.         Tcl_AppendResult(interp, "bad option \"", argv[2],
  140.             "\": should be read, write, or newtype",
  141.             (char *) NULL);
  142.         return TCL_ERROR;
  143.         }
  144.         sprintf(interp->result, "%d", length );
  145.         return TCL_OK;
  146.     }
  147.     break;
  148.       case 'd':
  149.     if (strncmp(argv[1], "debug", length) == 0) {
  150.         return Struct_DebugInfo(cdata,interp,argc,argv);
  151.     }
  152.     break;
  153.       case 'e':
  154.     if (strncmp(argv[1], "exists", length) == 0) {
  155.         if (argc != 3) {
  156.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  157.             " exists objName\"", (char *) NULL);
  158.         return TCL_ERROR;
  159.         }
  160.  
  161.         interp->result = (STRUCT_GETOBJECT(interp, argv[2])) ? "1" : "0";
  162.         return TCL_OK;
  163.     }
  164.     break;
  165.       case 'g':
  166.     if (strncmp(argv[1], "generate", length) == 0) {
  167.         if (argc > 3) {
  168.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  169.             " generate ?prefix?\"", (char *) NULL);
  170.         return TCL_ERROR;
  171.         }
  172.  
  173.         Tcl_AppendResult(interp,
  174.         Struct_GenerateName((argc == 3) ? argv[2] : "gen" ),
  175.         (char *)NULL );
  176.         return TCL_OK;
  177.     }
  178.     break;
  179.       case 'o':
  180.     if (strncmp(argv[1], "object", length) == 0) {
  181.         Struct_Object objbuf;
  182.  
  183.         if (argc < 3 || argc > 5 ||
  184.                 (argc > 4 && strncmp(argv[3],"type",strlen(argv[3])) != 0)) {
  185.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  186.             " object obj ?info?\"", (char *) NULL);
  187.         return TCL_ERROR;
  188.         }
  189.         (void) Struct_GetObject(interp,argv[2],&objbuf);
  190.         if (argc == 3) {
  191.         /* Does object exist? */
  192.         interp->result = (objbuf.type != NULL) ? "1" : "0";
  193.         Struct_ReleaseType(objbuf.type);
  194.         return TCL_OK;
  195.         }
  196.         if (objbuf.type == NULL) {
  197.             return TCL_ERROR;
  198.         }
  199.  
  200.         length = strlen(argv[3]);
  201.         if (strncmp(argv[3],"address",length) == 0) {
  202.         sprintf( interp->result, "%d", (int)objbuf.data );
  203.         } else if (strncmp(argv[3],"size",length) == 0) {
  204.         sprintf( interp->result, "%d", objbuf.size );
  205.         } else if (strncmp(argv[3],"type",length) == 0) {
  206.          if (argc > 4) {
  207.             type = objbuf.type;
  208.             argv[3] = argv[4];
  209.             goto type_info;
  210.         }
  211.         if (objbuf.type->name == NULL) {
  212.             Tcl_AppendResult(interp, "object has anonymous type", (char *)NULL );
  213.             Struct_ReleaseType(objbuf.type);
  214.             return TCL_ERROR;
  215.         }
  216.         interp->result = objbuf.type->name;
  217.         } else {
  218.         Tcl_AppendResult(interp, "bad option \"", argv[3],
  219.             "\": should be address, size, or type",
  220.             (char *) NULL);
  221.         Struct_ReleaseType(objbuf.type);
  222.         return TCL_ERROR;
  223.         }
  224.         Struct_ReleaseType(objbuf.type);
  225.         return TCL_OK;
  226.     }
  227.     break;
  228.       case 'p':
  229.     if (strncmp(argv[1], "patchlevel", length) == 0) {
  230.         char *value;
  231.         if (argc != 2) {
  232.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  233.             " patchlevel\"", (char *) NULL);
  234.         return TCL_ERROR;
  235.         }
  236.         if ((value = Tcl_GetVar(interp, "struct_patchLevel",
  237.             TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG)) == NULL)
  238.         return TCL_ERROR;
  239.         interp->result = value;
  240.         return TCL_OK;
  241.     }
  242.     break;
  243.       case 's':
  244.     if ((strncmp(argv[1], "sizeof", length) == 0)) {
  245.         Struct_Object  objbuf;
  246.  
  247.         if (argc!=3) {
  248.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  249.                    " sizeof type|object\"", (char *) NULL);
  250.         return TCL_ERROR;
  251.         }
  252.  
  253.         /* Is argv[2] a valid type name? */
  254.         if ((type = Struct_LookupType(cdata,interp,argv[2])) != NULL) {
  255.         sprintf( interp->result, "%d", type->size );
  256.         Struct_ReleaseType(type);
  257.         return TCL_OK;
  258.         }
  259.  
  260.         /* Is argv[2] an object? */
  261.         if (Struct_GetObject(interp,argv[2],&objbuf) == TCL_OK) {
  262.         sprintf( interp->result, "%d", objbuf.size );
  263.         Struct_ReleaseType(objbuf.type);
  264.         return TCL_OK;
  265.         }
  266.  
  267.         Tcl_ResetResult(interp);
  268.         Tcl_AppendResult(interp,"\"",argv[2],
  269.         "\" is neither a valid type nor a valid object",NULL);
  270.         return TCL_ERROR;
  271.     }
  272.     break;
  273.       case 't':
  274.     if (length < 4)
  275.         break;
  276.     if ((strncmp(argv[1], "type", length) == 0)) {
  277.         if (argc < 3 || argc >> 4) {
  278.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  279.             " type type ?info?\"", (char *) NULL);
  280.         return TCL_ERROR;
  281.         }
  282.         type = Struct_LookupType(cdata,interp,argv[2]);
  283.         if (argc == 3) {
  284.             /* Does type exist? */
  285.             if (type != NULL)
  286.             Struct_ReleaseType(type);
  287.             interp->result = (type != NULL) ? "1" : "0";
  288.             return TCL_OK;
  289.         }
  290.         if (type == NULL) {
  291.             return TCL_ERROR;
  292.         }
  293.  
  294. type_info:
  295.         length = strlen(argv[3]);
  296.         if (length == 0) {    /* Don't match anything */
  297.         /*EMPTY*/;
  298.         } else if (length >= 2 && strncmp(argv[3],"address",length) == 0) {
  299.         sprintf( interp->result, "%p", (void *)type );
  300.         } else if (length >= 2 && strncmp(argv[3],"align",length) == 0) {
  301.         sprintf( interp->result, "%d", type->align );
  302.         } else if (length >= 2 && strncmp(argv[3],"basic",length) == 0) {
  303.         interp->result = (type->flags & STRUCT_FLAG_TRACE_BASIC) ?
  304.                 "1" : "0";
  305.         } else if (length >= 2 && strncmp(argv[3],"builtin",length) == 0) {
  306.         interp->result = (type->flags & STRUCT_FLAG_BUILTIN) ?
  307.                 "1" : "0";
  308.         } else if (length >= 5 && strncmp(argv[3],"elemnames",length) == 0) {
  309.         if (type->flags & STRUCT_FLAG_IS_STRUCT) {
  310.             Struct_StructElem *pelem;
  311.             for ( pelem = type->u.s.struct_def;
  312.               pelem->type != NULL; pelem++ )
  313.             Tcl_AppendElement(interp,pelem->name);
  314.         }
  315.         } else if (length >= 5 && strncmp(argv[3],"elemtype",length) == 0) {
  316.         if (type->flags & (STRUCT_FLAG_IS_ARRAY|STRUCT_FLAG_IS_POINTER)) {
  317.             if (type->u.a.array_elem->name != NULL)
  318.             interp->result = type->u.a.array_elem->name;
  319.         }
  320.         } else if (length >= 2 && strncmp(argv[3],"endian",length) == 0) {
  321.         if (type->flags & STRUCT_FLAG_USE_ENDIAN)
  322.             interp->result = (type->flags & STRUCT_FLAG_BIG_ENDIAN) ?
  323.             "big" : "little";
  324.         } else if (length >= 2 && strncmp(argv[3],"fill",length) == 0) {
  325.         if (type->fill != NULL)
  326.             interp->result = type->fill;
  327.         } else if (length >= 2 && strncmp(argv[3],"flags",length) == 0) {
  328.         sprintf( interp->result, "%d", type->flags );
  329. #ifdef STRUCT_FLAG_USE_JUST
  330.         } else if (strncmp(argv[3],"justify",length) == 0) {
  331.             if (type->flags & STRUCT_FLAG_USE_JUST)
  332.          switch (type->flags & STRUCT_FLAG_JUST_MASK) {
  333.           case STRUCT_FLAG_JUST_NONE:
  334.             interp->result = "none"; break;
  335.           case STRUCT_FLAG_JUST_LEFT:
  336.             interp->result = "left"; break;
  337.           case STRUCT_FLAG_JUST_RIGHT:
  338.             interp->result = "right"; break;
  339.           case STRUCT_FLAG_JUST_CENTER:
  340.             interp->result = "center"; break;
  341.         }
  342. #endif    /*STRUCT_FLAG_USE_JUST*/
  343.         } else if (strncmp(argv[3],"kind",length) == 0) {
  344.         switch (type->flags & STRUCT_FLAG_IS_MASK) {
  345.             case STRUCT_FLAG_IS_BUILTIN:
  346.             interp->result = "builtin"; break;
  347.             case STRUCT_FLAG_IS_ARRAY:
  348.             interp->result = "array"; break;
  349.             case STRUCT_FLAG_IS_STRUCT:
  350.             interp->result = "struct"; break;
  351.             case STRUCT_FLAG_IS_POINTER:
  352.             interp->result = "pointer"; break;
  353.             case STRUCT_FLAG_IS_ADDR:
  354.             interp->result = "address"; break;
  355.         }
  356.         } else if (length >= 2 && strncmp(argv[3],"name",length) == 0) {
  357.         if (type->name != NULL)
  358.             interp->result = type->name;
  359.         } else if (length >= 2 && strncmp(argv[3],"nullok",length) == 0) {
  360.         if (type->flags & STRUCT_FLAG_USE_NULLOK)
  361.             interp->result = (type->flags & STRUCT_FLAG_NULL_OK) ?
  362.             "1" : "0";
  363.         } else if (strncmp(argv[3],"refcount",length) == 0) {
  364.         sprintf( interp->result, "%d", type->refcount - 1 );
  365.         } else if (length >= 2 && strncmp(argv[3],"size",length) == 0) {
  366.         sprintf( interp->result, "%d", type->size );
  367.         } else if (length >= 2 && strncmp(argv[3],"strict",length) == 0) {
  368.             interp->result = (type->flags & STRUCT_FLAG_STRICT) ?
  369.             "1" : "0";
  370.         } else if (strncmp(argv[3],"traceproc",length) == 0) {
  371.         sprintf( interp->result, "%p", (void *)type->TraceProc );
  372.         } else if (strncmp(argv[3],"unsigned",length) == 0) {
  373.         if (type->flags & STRUCT_FLAG_USE_SIGN)
  374.             interp->result = (type->flags & STRUCT_FLAG_UNSIGNED) ?
  375.             "1" : "0";
  376.         } else if (strncmp(argv[3],"varlen",length) == 0) {
  377.         interp->result = (type->flags & STRUCT_FLAG_VARLEN) ?
  378.                 "1" : "0";
  379.         } else {
  380.         Tcl_AppendResult(interp, "bad option \"", argv[3],
  381.             "\": should be address, align, basic, builtin, elemnames",
  382.             ", elemtype, endian, fill, flags",
  383. #ifdef STRUCT_FLAG_USE_JUST
  384.             ", justify",
  385. #endif    /*STRUCT_FLAG_USE_JUST*/
  386.             ", kind, name, nullok, refcount, size",
  387.             ", strict, traceproc, unsigned, or varlen",
  388.             (char *) NULL);
  389.         Struct_ReleaseType(type);
  390.         return TCL_ERROR;
  391.         }
  392.  
  393.         Struct_ReleaseType(type);
  394.         return TCL_OK;
  395.     } else if ((strncmp(argv[1], "typeof", length) == 0)) {
  396.         if (argc!=3) {
  397.         Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  398.                    " typeof type|object\"", (char *) NULL);
  399.         return TCL_ERROR;
  400.         }
  401.  
  402.         /* What is type of argv[2]? */
  403.         if ((type = Struct_Typeof(cdata,interp,argv[2])) == NULL) {
  404.         return TCL_ERROR;
  405.         }
  406.  
  407.         if (type->name == NULL) {
  408.             Tcl_ResetResult(interp);
  409.         Tcl_AppendResult(interp, "no name associated with this type", (char *)NULL );
  410.         Struct_ReleaseType(type);
  411.         return TCL_ERROR;
  412.         }
  413.  
  414.         interp->result = type->name;
  415.         Struct_ReleaseType(type);
  416.         return TCL_OK;
  417.     } else if ((strncmp(argv[1], "types", length) == 0)) {
  418.         Tcl_HashEntry *entryPtr;
  419.         Tcl_HashSearch search;
  420.         char *name;
  421.         if (argc > 3) {
  422.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  423.             argv[0], " types ?pattern?\"", (char *) NULL);
  424.         return TCL_ERROR;
  425.         }
  426.         for ( entryPtr = Tcl_FirstHashEntry(Struct_TypeHash(cdata), &search);
  427.               entryPtr != NULL;
  428.           entryPtr = Tcl_NextHashEntry(&search) ) {
  429.         name = Tcl_GetHashKey(Struct_TypeHash(cdata), entryPtr);
  430.         if ((argc == 3) && !Tcl_StringMatch(name, argv[2])) {
  431.             continue;
  432.         }
  433.         Tcl_AppendElement(interp, name);
  434.         }
  435.         return TCL_OK;
  436.     }
  437.     break;
  438.       case 'v':
  439.     if ((strncmp(argv[1], "version", length) == 0)) {
  440.         char *value;
  441.  
  442.         if (argc != 2) {
  443.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  444.             argv[0], " struct_version\"", (char *) NULL);
  445.         return TCL_ERROR;
  446.         }
  447.         if ((value = Tcl_GetVar(interp, "struct_version",
  448.             TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG)) == NULL)
  449.         return TCL_ERROR;
  450.  
  451.         interp->result = value;
  452.         return TCL_OK;
  453.     }
  454.     break;
  455.     }
  456.  
  457.     Tcl_AppendResult(interp, "bad option \"", argv[1],
  458.         "\": should be ",
  459.         "count, exists, generate, ",
  460.         "object, patchlevel, ",
  461.         "sizeof, type, typeof, ",
  462.         "types, or version",
  463.         (char *)NULL );
  464.     return TCL_ERROR;
  465. }
  466.